package StmtFSM (
                 -- re-exports from the Stmt package
                 StmtT(..),
                 StmtTifiable(..),
                 RStmt(..),
                 Stmt(..),
                 StmtM(..),
                 RStmts,
                 unS, _s__, s,
                 PosInfo, noPosInfo, getPIString, addPIPrefix,
                 await, delay, Once(..), mkOnce,
                 -- new exports
                 RFSM(..), FSMAbort(..), mkRFSM,
                 FSM(..), FSMServer(..),
                 mkFSM, mkFSMWithPred, mkAutoFSM, mkFSMServer, mkAlwaysFSM, mkAlwaysFSMWithPred,
                 ServerCallToStmtT(..), ActionType(..), Freedom(..)
                      ) where

-- #############################################################################
-- #
-- #############################################################################

import ClientServer
import ConfigReg
import DReg
import FIFO
import GetPut
import List
import TurboFIFO
import ToString

-- #############################################################################
-- #
-- #############################################################################
idle_state :: Integer
idle_state = 0

--type PosInfo = (String, Position__)
type PosInfo = String

noPosInfo :: PosInfo
--noPosInfo = ("_np", noPosition)
noPosInfo = "_np"

getPIString :: PosInfo -> String
--getPIString (l, p) = l
getPIString l = l

getPIPosition :: PosInfo -> Position__
getPIPosition l = getStringPosition( getPIString l)

addPIPrefix :: String -> PosInfo -> PosInfo
--addPIPrefix x (l,p) = ((x +++ l), p)
addPIPrefix x y = (x +++ y)

data Freedom
        = Early String -- string is comment for warning message
        | Overlap
    deriving (Eq)

data ActionType
        = Default
        | Update Freedom
        | Jump String
        | Wait
        | NoME
    deriving (Eq)

nAT :: Maybe ActionType
nAT = Nothing

-- #############################################################################
-- #
-- #############################################################################

eR :: Rules
eR = emptyRules

nR :: Maybe RuleSet
nR = Nothing

struct RuleSet
  =
    me_local   :: Rules
    me_parents :: Rules
    no_me      :: Rules


emptyRuleSet :: RuleSet
emptyRuleSet = RuleSet {me_local   = eR;
                        me_parents = eR;
                        no_me      = eR}

combineRuleSets :: RuleSet -> RuleSet -> RuleSet
combineRuleSets rs0 rs1 =
                RuleSet {me_local   = (rJoinMutuallyExclusive rs0.me_local rs1.me_local);
                         me_parents = (rJoin rs0.me_parents rs1.me_parents);
                         no_me      = (rJoin rs0.no_me rs1.no_me) }

mergeRuleSets :: RuleSet -> RuleSet -> RuleSet
mergeRuleSets rs0 rs1 =
                RuleSet {me_local   = (rJoin rs0.me_local rs1.me_local);
                         me_parents = (rJoin rs0.me_parents rs1.me_parents);
                         no_me      = (rJoin rs0.no_me rs1.no_me) }

-- #############################################################################
-- #
-- #############################################################################

data StmtT a
        = SAction PosInfo Action (Maybe ActionType)
        | SActionValue PosInfo (ActionValue a)
        | SNamed PosInfo String  (List (StmtT a))
        | SLabel PosInfo String Bool (Maybe (StmtT a))
        | SJump PosInfo String
        | SCall PosInfo Action Action Action -- abort_action, start_action, end_action
        | SUntil PosInfo Bool
        | SIf1 PosInfo Bool (StmtT a)
        | SIf2 PosInfo Bool (StmtT a) (StmtT a)
        | SWhile PosInfo Bool (StmtT a) (Maybe (StmtT a)) (Maybe (StmtT a)) (Maybe (StmtT a)) -- init_action, pre_action, post_action
        | SFor PosInfo (StmtT a) Bool (StmtT a) (StmtT a)
        | SSeq PosInfo (List (StmtT a))
        | SPar PosInfo (List (StmtT a))
        | SSkip PosInfo
        | SRepeat PosInfo Nat (StmtT a)
        | SDelay PosInfo Nat
        | SReturn PosInfo
        | SBreak PosInfo
        | SContinue PosInfo
        | SExprS PosInfo (RStmt a)

class StmtTifiable t a | t -> a where stmtify :: PosInfo -> t -> (StmtT a)

instance StmtTifiable Action t where
    stmtify p a = SAction p a Nothing

instance StmtTifiable (RStmt a) a where
    stmtify p st = SExprS p st

-- #############################################################################
-- #
-- #############################################################################

type RStmts a = List (StmtT a)

type RStmt a = StmtM a ()

data StmtM a b
        = S (Module (b, (RStmts a)))

unS :: StmtM a b -> Module (b, (RStmts a))
unS (S x) = x

instance Monad (StmtM a)
  where
    return x = S (return (x, Nil))
    bind (S x) f = S
        do  (xa, xs) <- x
            (fa, fs) <- unS (f xa)
            return (fa, xs `append` fs)

stmt :: (Monad m) => (StmtT a) -> m ((), (RStmts a))
stmt st = return ((), st :> Nil)

_s__ :: StmtT a -> RStmt a
_s__ st = S (stmt st)

s :: Action -> RStmt a
s x = _s__ (SAction noPosInfo x Nothing)

type Stmt = RStmt (Bit 0)

-- #############################################################################
-- #
-- #############################################################################

stmtTToString :: (Monad m) => (StmtT a) -> m String
stmtTToString (SAction p _ (Just Default)) = return ("[DD Action" +++ (getPIString p) +++ "]")
stmtTToString (SAction p _ (Just (Jump l))) = return ("[Jump Action" +++ (getPIString p) +++ " " +++ l +++ "]")
stmtTToString (SAction p _ _) = return ("[Action" +++ (getPIString p) +++ "]")
stmtTToString (SActionValue p _) = return ("[ActionValue" +++ (getPIString p) +++ "]")
stmtTToString (SIf1 p _ st)  =
    do sub <- stmtTToString st
       return ("[If1" +++(getPIString p)+++ " " +++ sub +++ "]")
stmtTToString (SIf2 p _ s0 s1)  =
    do sub0 <- stmtTToString s0
       sub1 <- stmtTToString s1
       return ("[If2" +++(getPIString p)+++ " " +++ sub0 +++ " " +++ sub1 +++ "]")
stmtTToString (SSeq p ss) =
    do subs <- stmtTListToString ss
       return ("[Seq" +++(getPIString p)+++ " " +++ subs +++ "]")
stmtTToString (SPar p ss) =
    do subs <- stmtTListToString ss
       return ("[Par" +++(getPIString p)+++ " " +++ subs +++ "]")
stmtTToString (SSkip p) = return ("[Skip" +++(getPIString p)+++ "]")
stmtTToString (SCall p _ _ _) = return ("[Call" +++(getPIString p)+++ "]")
stmtTToString (SReturn p) = return ("[Return" +++(getPIString p)+++ "]")
stmtTToString (SBreak p) = return ("[Break" +++(getPIString p)+++ "]")
stmtTToString (SContinue p) = return ("[Continue" +++(getPIString p)+++ "]")
stmtTToString (SLabel p name _ _) = return ("[Label " +++ name +++(getPIString p)+++ "]")
stmtTToString (SJump p name) = return ("[Jump " +++ name +++(getPIString p)+++ "]")
stmtTToString (SUntil _ _) = return ("[SUntil]")
stmtTToString (SWhile p _ st _ _ _) =
    do sub <- stmtTToString st
       return ("[While" +++(getPIString p)+++ " " +++ sub +++ "]")
stmtTToString (SRepeat p _ st) =
    do sub <- stmtTToString st
       return ("[Repeat" +++(getPIString p)+++ " " +++ sub +++ "]")
stmtTToString (SDelay p _) =
    return ("[Delay" +++(getPIString p)+++ " " +++ "]")
stmtTToString (SFor p s1 _ s2 s3) =
    do x1 <- stmtTToString s1
       x2 <- stmtTToString s2
       x3 <- stmtTToString s3
       return ("[SFor" +++(getPIString p)+++ " " +++ x1 +++ " " +++ x2 +++ " " +++ x3 +++ "]")
stmtTToString (SNamed p nm Nil)  =
    return ("[SNamed " +++ nm +++(getPIString p)+++ "]")
stmtTToString (SNamed p nm (Cons st Nil)) =
    do sub <- stmtTToString st
       return ("[SNamed " +++ nm +++(getPIString p)+++ " [" +++ sub +++ "]]")

stmtTToString (SExprS p _) = return ("[SExprS " +++(getPIString p)+++ "]")
--stmtTToString _ = return "XXXX"
stmtTToString _ = error "unhandled case"

stmtTListToString :: (Monad m) => (List (StmtT a)) -> m String
stmtTListToString x =
    do y <- stmtTListToStringInternal x
       return ("(" +++ y +++ ")")

stmtTListToStringInternal :: (Monad m) => (List (StmtT a)) -> m String
stmtTListToStringInternal Nil = return ""
stmtTListToStringInternal (Cons x Nil) = stmtTToString x
stmtTListToStringInternal (Cons x rest) =
    do y <- stmtTToString x
       z <- stmtTListToStringInternal rest
       return (y +++ " " +++ z)

-- #############################################################################
-- #
-- #############################################################################

getStmtTPosInfo :: (StmtT a) -> PosInfo
getStmtTPosInfo (SAction p _ _) = p
getStmtTPosInfo (SActionValue p _) = p
getStmtTPosInfo (SCall p _ _ _) = p
getStmtTPosInfo (SIf1 p _ _)  = p
getStmtTPosInfo (SIf2 p _ _ _)  = p
getStmtTPosInfo (SSeq p _) = p
getStmtTPosInfo (SPar p _) = p
getStmtTPosInfo (SSkip p) = p
getStmtTPosInfo (SReturn p) = p
getStmtTPosInfo (SBreak p) = p
getStmtTPosInfo (SContinue p) = p
getStmtTPosInfo (SExprS p _) = p
getStmtTPosInfo (SWhile p _ _ _ _ _) = p
getStmtTPosInfo (SRepeat p _ _) = p
getStmtTPosInfo (SDelay p _) = p
getStmtTPosInfo (SFor p _ _ _ _) = p
getStmtTPosInfo _ = error "unhandled case"


-- #############################################################################
-- #
-- #############################################################################

delay :: (Eq a, Ord a, Arith a, Literal a, Bits a sa, Add x sa 32) => a -> RStmt b
-- delay num = _s__ (SRepeat noPosInfo (zeroExtend (pack num)) (SAction noPosInfo noAction Nothing))
delay num = _s__ (SDelay noPosInfo (zeroExtend (pack num)))

-- await :: Bool -> RStmt a
-- await cond = _s__ (SUntil noPosInfo cond)

-- #############################################################################
-- #
-- #############################################################################

interface Waiter =
     wait :: Action

await :: Bool -> Action
await condition =
 let w = interface Waiter
           wait :: Action
           wait = noAction
                  when condition
 in w.wait

-- #############################################################################
-- #
-- #############################################################################

interface Once =
    start :: Action
    clear :: Action
    done :: Bool

mkOnce :: (IsModule m c) => Action -> m Once
mkOnce a =
    module
        onceReady :: Reg Bool
        onceReady <- mkReg True
        interface
            start = action { onceReady := False; a }
                when onceReady
            clear = action { onceReady := True }
            done = onceReady == False ;

-- #############################################################################
-- #
-- #############################################################################

-- #############################################################################
-- #
-- #############################################################################

interface RFSM a =
    start         :: Action
    abort         :: Action
    ready         :: Bool

interface FSMAbort =
    abort :: Action

interface FSM =
    start :: Action
    done  :: Bool
    waitTillDone :: Action
    abort :: Action

interface FSMServer a b =
    server   :: Server a b
    abort    :: Action

-- #############################################################################
-- #
-- #############################################################################

type NextStateDescriptor
    = (Bool, Integer)

type NextStateDescriptors
    = (List NextStateDescriptor)

type TwoStateDescriptor_orig
    = (Bool, Integer, Integer)

data TwoStateDescriptor = TSD Bool Integer Integer TSDType
                          deriving (Eq)

data TSDType
        = Default
        | Start
        | End
    deriving (Eq)

combineTSDTypes :: TSDType -> TSDType -> TSDType
combineTSDTypes Start   _       = Start
combineTSDTypes _       Start   = Start
combineTSDTypes End     _       = End
combineTSDTypes _       End     = End
combineTSDTypes _       _       = Default

type TwoStateDescriptors
    = (List TwoStateDescriptor)

-- #############################################################################
-- #
-- #############################################################################

compareNSDs :: NextStateDescriptor -> NextStateDescriptor -> Ordering
compareNSDs (_conda, a) (_condb, b) = compare a b

matchingNSDs :: NextStateDescriptor -> NextStateDescriptor -> Bool
matchingNSDs a b = ((compareNSDs a b) == EQ)


compareTSDs :: TwoStateDescriptor -> TwoStateDescriptor -> Ordering
compareTSDs (TSD _conda a0 a1 _) (TSD _condb b0 b1 _) =
            if      (a1 < b1) then LT
            else if (a1 > b1) then GT
            else if (a0 < b0) then LT
            else if (a0 > b0) then GT
            else                   EQ

matchingTSDs :: TwoStateDescriptor -> TwoStateDescriptor -> Bool
--matchingTSDs a b = ((compareTSDs a b) == EQ)
matchingTSDs (TSD _ _ a _) (TSD _ _ b _) = (a == b)

getFrom :: TwoStateDescriptor -> Integer
getFrom (TSD _ f _ _) = f

getTo :: TwoStateDescriptor -> Integer
getTo (TSD _ _ t _) = t

-- #############################################################################
-- #
-- #############################################################################

class ServerCallToStmtT t where
      callServer :: (ToPut i b) => t a b -> a -> i -> PosInfo -> (RStmt c)

instance ServerCallToStmtT Server where
      callServer ifc value lhs ps =
       _s__ (SCall ps
                      noAction
                      action { ifc.request.put(value) }
                      action { x <- ifc.response.get; (toPut lhs).put x })

instance ServerCallToStmtT FSMServer where
      callServer ifc value lhs ps =
       _s__ (SCall    ps
                      action { ifc.abort }
                      action { ifc.server.request.put(value) }
                      action { x <- ifc.server.response.get; (toPut lhs).put x })

-- #############################################################################
-- #
-- #############################################################################

data StmtFT a
        =  SFAction PosInfo Integer NextStateDescriptors Action Action (Maybe ActionType) (Maybe RuleSet)
        | SFLabel PosInfo String NextStateDescriptors (Maybe (StmtT a))
        | SFNamed PosInfo String  (List (StmtFT a))
        | SFUntil PosInfo Bool
        | SFIf1 PosInfo Bool (StmtFT a)
        | SFIf2 PosInfo Bool (StmtFT a) (StmtFT a)
        | SFFor PosInfo (StmtFT a) Bool (StmtFT a) (StmtFT a)
        | SFSeq PosInfo (List (StmtFT a))
        | SFPar PosInfo (StmtFT a) (List (StmtT a))
        | SFSkip PosInfo
        | SFDelay PosInfo
        | SFReturn PosInfo
        | SFWhile PosInfo Bool (StmtFT a)

-- #############################################################################
-- #
-- #############################################################################

struct LabelState a
  =
    state_num    :: Integer
    return_label :: String
    label_names  :: (List String)
    loop_labels  :: (Maybe (String, String))
    ifc          :: (Put a)

initLabelState :: Integer -> String -> (Put a) -> (LabelState a)
initLabelState num return_label ifc = LabelState {
                   state_num    = num;
                   return_label = return_label;
                   label_names  = Nil;
                   loop_labels  = Nothing;
                   ifc = ifc }

incrLabelState :: (LabelState a) -> (LabelState a)
incrLabelState ls = ls { state_num = ls.state_num + 1 }

isLabelUsed :: String -> (LabelState a) -> Bool
isLabelUsed label ls =
  let check x = x == label
      r = (find check ls.label_names)
  in isJust r

createUniqueLabel :: String -> (LabelState a) -> String
createUniqueLabel label ls =
   if (isLabelUsed label ls)
   then (createUniqueLabelWithSuffix label 1 ls)
   else label

createUniqueLabelWithSuffix :: String -> Integer -> (LabelState a) -> String
createUniqueLabelWithSuffix label suffix ls =
   let l = (label +++ "_" +++ (integerToString suffix))
   in if (isLabelUsed l ls)
      then (createUniqueLabelWithSuffix label (suffix + 1) ls)
      else l

addLabel :: String -> (LabelState a) -> (LabelState a)
addLabel label ls = ls { label_names = (Cons label ls.label_names) }

addLoopLabels :: String -> String -> (LabelState a) -> (LabelState a)
addLoopLabels continue break ls = ls { loop_labels = (Just (continue, break)) }

-- #############################################################################
-- # Convert StmtTs to StmtFTs and label all the actiuons uniquely.
-- #############################################################################

labelActions :: (IsModule m c) => (StmtT a) -> (LabelState a) -> m ((StmtFT a), (LabelState a))
labelActions (SAction p a at) ls =
    return ((SFAction p ls.state_num Nil noAction a at nR), incrLabelState(ls))

labelActions (SActionValue p av) ls =
    do let st = (SFSeq p
                (Cons (SFAction p ls.state_num Nil noAction action {x <- av; ls.ifc.put x} nAT nR)
                 (Cons (SFReturn p) Nil)))
       return (st, incrLabelState(ls))

labelActions (SCall p a_abort a_start a_done) ls =
    do let st = (SFSeq p (Cons
                        (SFAction p ls.state_num Nil a_abort a_start nAT nR)
                         (Cons (SFAction p (ls.state_num + 1) Nil noAction a_done nAT nR) Nil)))
       return (st, incrLabelState(incrLabelState(ls)))

labelActions (SIf1 p c st) ls =
    if (isStaticAndFalse c)
    then labelActions (SSkip p) ls
    else do (r, ls') <- labelActions st ls
            return ((SFIf1 p c r), ls')

labelActions (SIf2 p c s0 s1) ls =
    if (isStaticAndFalse c)
    then labelActions s1 ls
    else if (isStaticAndTrue c)
    then labelActions s0 ls
    else do (r0, ls0) <- labelActions s0 ls
            (r1, ls1) <- labelActions s1 ls0
            return ((SFIf2 p c r0 r1), ls1)

labelActions (SSeq p Nil) ls =
     labelActions (SSkip p) ls

labelActions x@(SSeq p (Cons st Nil)) ls =
    do _ <- stmtTToString x
       -- messageM("S0 " +++ y)
       (r, ls0) <- labelActions st ls
       return ((SFSeq p (Cons r Nil)), ls0)

labelActions (SSeq p (Cons (SExprS pe e) rest)) ls =
    do (_, ss) <- liftModule (unS e)
       labelActions (SSeq p (Cons (SSeq pe ss) rest)) ls

labelActions (SSeq p (Cons s0 (Cons (SExprS pe e) rest))) ls =
    do (_, ss) <- liftModule (unS e)
       labelActions (SSeq p (Cons s0 (Cons (SSeq pe ss) rest))) ls

labelActions (SSeq p (Cons (SSeq _ s0) rest)) ls =
    do let x = (SSeq p (append s0 rest))
       _ <- stmtTToString x
       -- messageM("S " +++ y)
       labelActions x ls

labelActions (SSeq p (Cons s0 (Cons (SSeq _ s1) rest))) ls =
    do let x = (SSeq p (Cons s0 (append s1 rest)))
       _ <- stmtTToString x
       -- messageM("S " +++ y)
       labelActions x ls

labelActions x@(SSeq p (Cons st ss)) ls =
    do _ <- stmtTToString x
       -- messageM("S1 " +++ y)
       (_r,  ls0)   <- labelActions st        ls
       (_rr, ls1) <- labelActions (SSeq p ss) ls0
       return ((SFSeq p (Cons _r (getStmtFTList _rr))), ls1)

labelActions (SPar p Nil) ls =
     labelActions (SSkip p) ls

labelActions (SPar _ (Cons st Nil)) ls =
     labelActions st ls

labelActions (SPar p ss) ls =
    do (r, ls0) <- labelActions (SAction p noAction Nothing) ls
       return ((SFPar p r ss), (incrLabelState (incrLabelState ls0)))

labelActions (SSkip p)     ls = return ((SFSkip p), ls)

labelActions (SReturn p)    ls =
     do let return = ls.return_label
            r      = (SAction p noAction (Just (Jump return)))
        labelActions r ls

labelActions (SBreak p)    ls =
     do let msg = setStringPosition "break is not inside a loop construct." (getPIPosition p)
            loop_labels  = ls.loop_labels
            (_continue, break) = (unJust loop_labels)
            r            = (SAction p noAction (Just (Jump break)))
        if (not (isJust loop_labels)) then error msg
                                      else labelActions r ls

labelActions (SContinue p)    ls =
     do let msg = setStringPosition "continue is not inside a loop construct." (getPIPosition p)
            loop_labels  = ls.loop_labels
            (continue, _end) = (unJust loop_labels)
            r            = (SAction p noAction (Just (Jump continue)))
        if (not (isJust loop_labels)) then error msg
                                      else labelActions r ls

labelActions (SLabel p name True Nothing) ls =
     do return ((SFLabel p name Nil Nothing), (addLabel name ls))

labelActions (SLabel p name False Nothing) ls =
     do let msg = setStringPosition ("label '" +++ name +++ "' is already in use.") (getPIPosition p)
        if (isLabelUsed name ls) then error msg
                                 else return ((SFLabel p name Nil Nothing), (addLabel name ls))

labelActions (SJump p name) ls =
    labelActions (SAction p noAction (Just (Jump name))) ls

labelActions (SNamed p name (Cons st Nil)) ls =
    do (s0, ls0) <- labelActions st ls
       return ((SFNamed p name (Cons s0 Nil)), ls0)

labelActions (SNamed p name Nil) ls =
    do return ((SFNamed p name Nil), ls)

labelActions (SNamed p name Nil) ls =
    do -- messageM("Statement label is " +++ name)
       return ((SFNamed p name Nil), ls)

labelActions (SUntil p cond) ls =
    do (s', ls') <- labelActions (SAction p              action { --  $display "(%0d) wait!" $time
--    do (s', ls') <- labelActions (SAction ("WAIT" +++ p) action { --  $display "(%0d) wait!" $time
                                                                } (Just Wait)) ls
       return ((SFSeq p (Cons (SFUntil p cond) (Cons s' Nil))), ls')
--    do return ((SFUntil p cond), ls)

labelActions (SExprS p e) ls =
    do (_, ss) <- liftModule (unS e)
       labelActions (SSeq p ss) ls

-- #############################################################################
-- #
-- #############################################################################

labelActions (SWhile p c s0 (Just ss_init) s_pre s_post) ls =
     do let r = (SSeq p (Cons ss_init (Cons (SWhile p c s0 Nothing s_pre s_post) Nil)))
        labelActions r ls

labelActions (SWhile p c s0 Nothing s_pre s_post) ls =
     do let loop_labels = ls.loop_labels
            start    = (createUniqueLabelWithSuffix "_while_start" 0 ls)
            continue = (createUniqueLabelWithSuffix "_while_continue" 0 ls)
            break    = (createUniqueLabelWithSuffix "_while_break"   0 ls)
            ss_pre   = if (not (isJust s_pre)) then (SSkip p) else (unJust s_pre)
            ss_post  = if (not (isJust s_post)) then (SSkip p) else (unJust s_post)
            ls'      = (addLabel start
                         (addLabel continue
                           (addLabel break (addLoopLabels continue break ls))))

        let body = (SSeq p (Cons ss_pre (Cons s0 (Cons (SLabel p continue True Nothing) (Cons ss_post Nil)))))

        c_no_action <- getNoActionCondition body

        (st, ls'') <- if (isStaticAndFalse c_no_action)
                      then do (t, ls'') <- labelActions body ls'
                              let st' = (SFSeq p
                                       (Cons (SFWhile p c t)
                                        (Cons (SFLabel p break Nil Nothing) Nil)))
                              return (st', ls'')
                      else do let t = (SIf1 p c
                                       (SSeq p
                                        (Cons (SLabel p start True Nothing)
                                         (Cons body
                                          (Cons (SIf1 p c (SJump p start))
                                           (Cons (SLabel p break True Nothing) Nil))))))
                              (st', ls'') <- labelActions t ls'
                              return (st', ls'')

        return (st, ls'' { loop_labels = loop_labels })

labelActions (SDelay p x) ls =
     do let size = if (isStatic (pack x)) then (zExtend x) else 33000 -- gets a Bit#(16)
            pos  = getPIPosition p
        {-# hide #-}
        jj <- if (isStatic (pack x))
              then case (x) of
                 0 -> return ((SFSkip p), ls)
                 1 -> labelActions (SAction p noAction Nothing) ls
                 2 -> labelActions (SSeq p (Cons (SAction p noAction Nothing) (Cons (SAction p noAction Nothing) Nil))) ls
                 _ -> do delay_count <- mkNCount True size
                         let p_init      = (setStringPosition ("_d_init" +++ p) pos)
                             action_init = action { delay_count.reset }
                             s_init = (SAction p_init action_init Nothing)
                         labelActions (SSeq p (Cons s_init (Cons (SWhile p (not (delay_count.is (x-1))) (SAction p action {delay_count.incr} Nothing) Nothing Nothing Nothing) Nil))) ls
              else do delay_count <- mkNCount False size
                      let  p_init      = (setStringPosition ("_d_init" +++ p) pos)
                           action_init = action { delay_count.reset }
                           s_init = (SAction p_init action_init Nothing)
                      labelActions (SIf1 p (not (x == 0)) (SSeq p (Cons s_init (Cons (SWhile p (not (delay_count.is (x-1))) (SAction p action {delay_count.incr} Nothing) Nothing Nothing Nothing) Nil)))) ls
        return jj

labelActions (SRepeat p x st) ls =
     do let is_static = isStatic (pack x)
            size = if is_static then (zExtend x) else 33000 -- gets a Bit#(16)
            pos  = getPIPosition p
        {-# hide #-}
        jj <- if (is_static && x == 1)
              then labelActions st ls
              else if (is_static && x == 0)
                   then return ((SFSkip p), ls)
                   else do repeat_count <- mkNCount is_static size
                           let p_init   = setStringPosition ("_r_init" +++ p) pos
                               p_update = setStringPosition ("_r_update" +++ p) pos
                               action_init  = action { repeat_count.reset }
                               s_init = (SIf1 p (not (repeat_count.is 0)) (SAction p_init action_init Nothing))
                               update_action = action {if (repeat_count.is (x - 1)) then action {repeat_count.reset} else action { repeat_count.incr }}

                               s_pre = (SIf1 p (not (x == 0)) (SAction p_update update_action (Just (Update Overlap))))
                               s_post = (SIf1 p (repeat_count.is 0) (SBreak p))
                           labelActions (SWhile p (not (x == 0)) st (Just s_init) (Just s_pre) (Just s_post)) ls
        return jj

-- labelActions (SFor p (SAction p_init a_init _)  c (SAction p_update a_update _) s_body) ls =
--      do let pos_init       = getPIPosition p_init
--             pos_update     = getPIPosition p_update
--             p_init'        = setStringPosition ("_f_init" +++ p) pos_init
--             p_update'      = setStringPosition ("_f_update" +++ p) pos_update
--             comment_init   = (setStringPosition "For loop initialization action" pos_init)
--             comment_update = (setStringPosition "For loop update action" pos_update)
--         labelActions (SWhile p c s_body (Just (SAction p_init' a_init   (Just (Update (Early comment_init))))) Nothing
--                                         (Just (SAction p_update' a_update (Just (Update (Early comment_update)))))) ls

labelActions (SFor p (SAction p_init a_init _)  c (SAction p_update a_update _) s_body) ls =
     do let pos_init       = getPIPosition p_init
            pos_update     = getPIPosition p_update
            p_init'        = setStringPosition ("_f_init" +++ p) pos_init
            p_update'      = setStringPosition ("_f_update" +++ p) pos_update
        labelActions (SWhile p c s_body (Just (SAction p_init' a_init   Nothing   )) Nothing
                                        (Just (SAction p_update' a_update Nothing   ))) ls


-- #############################################################################
-- #
-- #############################################################################

labelActions st _ =
    do x <- stmtTToString st
       messageM ("Case: " +++ x)
       error "unhandled case"

-- #############################################################################
-- #
-- #############################################################################

isStatic :: (Bit n) -> Bool
isStatic  = isStaticIndex

isStaticAndFalse :: Bool -> Bool
isStaticAndFalse cond = (isStatic (pack cond)) && (not cond)

isStaticAndTrue :: Bool -> Bool
isStaticAndTrue cond = (isStatic (pack cond)) && cond

-- #############################################################################
-- #
-- #############################################################################

addNextStateDescriptors :: (Monad m) => (StmtFT a) -> NextStateDescriptors
                       -> m ((StmtFT a), NextStateDescriptors)
addNextStateDescriptors (SFAction p id _ a_abort a at rs) nsd =
    do
       let r = (SFAction p id nsd a_abort a at rs)
       -- messageM("adding " +++ (nextStateDescriptorsToString nsd) +++ " to action" +++ p +++ " (" +++ (integerToString id) +++ ") nsd_rtrn = " +++ (nextStateDescriptorsToString nsd_rtrn))
       return (r, (Cons (True, id) Nil))

-- TTTT
addNextStateDescriptors st@(SFPar _ _ _) nsd =
    return (st, nsd)

addNextStateDescriptors (SFSeq p (Cons st Nil)) nsd =
    do (r, x) <- addNextStateDescriptors st nsd
       return ((SFSeq p (Cons r Nil)), x)

addNextStateDescriptors (SFSeq p (Cons st ss)) nsd =
    do (r0, nsd0) <- addNextStateDescriptors (SFSeq p ss) nsd
       (r, nsd1) <- addNextStateDescriptors st nsd0
       let rr = (getStmtFTList r0)
       return ((SFSeq p (Cons r rr)), nsd1)

addNextStateDescriptors (SFIf1 p c st) nsd =
    addNextStateDescriptors (SFIf2 p c st (SFSkip p)) nsd

addNextStateDescriptors (SFIf2 p c s0 s1) nsd =
    do (r0, nsd0) <- addNextStateDescriptors s0 nsd
       (r1, nsd1) <- addNextStateDescriptors s1 nsd
       let nsd0a = applyConditionToAll c nsd0
       let nsd1a = applyConditionToAll (not c) nsd1
       return ((SFIf2 p c r0 r1), (appendDescriptors nsd0a nsd1a))

addNextStateDescriptors st@(SFSkip _) nsd =
    return (st, nsd)

addNextStateDescriptors (SFNamed p name (Cons st Nil)) nsd =
    do (s0, nsd0) <- addNextStateDescriptors st nsd
       return ((SFNamed p name (Cons s0 Nil)), nsd0)

addNextStateDescriptors (SFLabel p name _ Nothing) nsd =
    return ((SFLabel p name nsd Nothing), nsd)

addNextStateDescriptors st@(SFReturn _) _ =
    return (st, (Cons (True, idle_state) Nil))

addNextStateDescriptors st@(SFNamed _ _ Nil) nsd =
     return (st, nsd)

addNextStateDescriptors (SFNamed p name (Cons st Nil)) nsd =
    do (r, x) <- addNextStateDescriptors st nsd
       return ((SFNamed p name (Cons r Nil)), x)

addNextStateDescriptors st@(SFUntil _ c) nsd =
    do let nsd_mod = applyConditionToAll c nsd
       return (st, nsd_mod)

addNextStateDescriptors (SFWhile p c st) nsd =
    do let nsd_done = applyConditionToAll (not c) nsd
       (_r0, nsd0) <- addNextStateDescriptors st Nil
       let nsd_continue = applyConditionToAll c nsd0
       (r1, nsd1) <- addNextStateDescriptors st (appendDescriptors nsd_done nsd_continue)
       return ((SFWhile p c r1), (appendDescriptors nsd_done (applyConditionToAll c nsd1)))

addNextStateDescriptors st _ =
    do x <- stmtFTToString st
       messageM ("Case: " +++ x)
       error "unhandled case"

-- #############################################################################
-- #
-- #############################################################################

applyCondition :: Bool -> NextStateDescriptor -> NextStateDescriptor
applyCondition b (c,num) = ((b && c), num)

applyConditionToAll :: Bool -> NextStateDescriptors -> NextStateDescriptors
applyConditionToAll b descriptor = (map (applyCondition b) descriptor)

appendDescriptors :: NextStateDescriptors -> NextStateDescriptors -> NextStateDescriptors
appendDescriptors Nil descriptor = descriptor
appendDescriptors (Cons first rest) descriptor = appendDescriptors rest (addDescriptor first descriptor)

addDescriptor :: NextStateDescriptor -> NextStateDescriptors -> NextStateDescriptors
-- addDescriptor (c,i) (Cons (c', i') rest) = (Cons (c', i') (addDescriptor (c, i) rest))
addDescriptor (c,i) (Cons (c', i') rest) =
    if (i == i') then (Cons ((c || c'), i) rest)
                 else (Cons (c', i') (addDescriptor (c, i) rest))
addDescriptor x Nil = (Cons x Nil)

-- #############################################################################
-- #
-- #############################################################################

nextStateDescriptorToString :: NextStateDescriptor -> String
nextStateDescriptorToString (c,i) =
    let static = isStatic (pack c)
        out = if (static && c)
              then "(True, " +++ (integerToString i) +++ ")"
              else if (static && (not c))
              then "(False, " +++ (integerToString i) +++ ")"
              else  "(X, " +++ (integerToString i) +++ ")"
    in out

nextStateDescriptorsToString :: NextStateDescriptors -> String
nextStateDescriptorsToString x = "(" +++ (nextStateDescriptorsToStringInternal x) +++ ")"

nextStateDescriptorsToStringInternal :: NextStateDescriptors -> String
nextStateDescriptorsToStringInternal Nil = ""
nextStateDescriptorsToStringInternal (Cons x Nil) = nextStateDescriptorToString x
nextStateDescriptorsToStringInternal (Cons x rest) = (nextStateDescriptorToString x) +++ " " +++ (nextStateDescriptorsToStringInternal rest)

-- #############################################################################
-- #
-- #############################################################################

twoStateDescriptorToString :: TwoStateDescriptor -> String
twoStateDescriptorToString (TSD c from to Default) =
    "(" +++ (boolToString c) +++ ", " +++ (integerToString from) +++ ", " +++ (integerToString to) +++ ")"
twoStateDescriptorToString (TSD c from to Start) =
    "(" +++ (boolToString c) +++ ", " +++ (integerToString from) +++ ", " +++ (integerToString to) +++ " (S))"
twoStateDescriptorToString (TSD c from to End) =
    "(" +++ (boolToString c) +++ ", " +++ (integerToString from) +++ ", " +++ (integerToString to) +++ " (E))"

twoStateDescriptorsToString :: TwoStateDescriptors -> String
twoStateDescriptorsToString x = "(" +++ (twoStateDescriptorsToStringInternal x) +++ ")"

twoStateDescriptorsToStringInternal :: TwoStateDescriptors -> String
twoStateDescriptorsToStringInternal Nil = ""
twoStateDescriptorsToStringInternal (Cons x Nil) = twoStateDescriptorToString x
twoStateDescriptorsToStringInternal (Cons x rest) = (twoStateDescriptorToString x) +++ " " +++ (twoStateDescriptorsToStringInternal rest)


boolToString :: Bool -> String
boolToString c =
    let static = isStatic (pack c)
        out = if (static && c)
              then "True"
              else if (static && (not c))
              then "False"
              else "X"
    in out

-- #############################################################################
-- #
-- #############################################################################

getStmtFTList :: (StmtFT a) -> (List (StmtFT a))
getStmtFTList (SFSeq _ rr) = rr
getStmtFTList _ = error "unhandled case"

-- #############################################################################
-- #
-- #############################################################################

getNoActionConditionOrig :: (Monad m) => Integer -> (StmtFT a) -> m Bool
getNoActionConditionOrig num seq =
            do let -- temp = (createUniqueLabelWithSuffix "_temp" 0 ls)
                   -- ls'  = (addLabel temp ls)
                   m    = num
                   st   = (SFSeq noPosInfo (Cons (SFAction noPosInfo m Nil noAction noAction nAT nR)
                                 (Cons seq (Cons (SFAction noPosInfo (m + 1) Nil noAction noAction nAT nR) Nil))))
                   no_action (TSD _ f t _) = (f == m) && (t == (m + 1))
               (_, tsds) <- getRefinedTSDs True False True st
               let no_action_list = filter no_action tsds
                   getCond (TSD c _ _ _) = c
                   combined_cond Nil = False
                   combined_cond x   = foldr1 (||) (map getCond x)
               return (combined_cond no_action_list)


-- #############################################################################
-- #
-- #############################################################################


getNoActionCondition :: (IsModule m c) => (StmtT a) -> m Bool

getNoActionCondition (SAction _ _ Nothing) = return False
getNoActionCondition (SAction _ _ (Just (Jump _))) = return False
getNoActionCondition (SAction _ _ (Just (Update Overlap))) = return True
getNoActionCondition (SAction _ _ _)       = return False
getNoActionCondition (SJump _ _) = return False
getNoActionCondition (SContinue _) = return False
getNoActionCondition (SBreak _) = return False
getNoActionCondition (SReturn _) = return False
getNoActionCondition (SIf1 _ c s1)  =
    do c1 <- getNoActionCondition s1
       return ((c && c1) || (not c))
getNoActionCondition (SIf2 _ c s1 s2) =
    do c1 <- getNoActionCondition s1
       c2 <- getNoActionCondition s2
       return ((c && c1) || ((not c) && c2))
getNoActionCondition (SSeq _ (Cons st Nil)) = getNoActionCondition st
getNoActionCondition (SSeq p (Cons st ss)) =
    do c0 <- getNoActionCondition st
       c1 <- getNoActionCondition (SSeq p ss)
       return (c0 && c1)
getNoActionCondition (SExprS p e) =
    do (_, ss) <- liftModule (unS e)
       getNoActionCondition (SSeq p ss)
getNoActionCondition (SWhile _ c _ (Just ss_init) _ _) =
    do c_init <- getNoActionCondition ss_init
       return (c_init  && (not c))
getNoActionCondition (SWhile _ c _ _ _ _) = return (not c)
getNoActionCondition (SRepeat _ n _) = return (n == 0)
getNoActionCondition (SDelay _ n) = return (n == 0)
getNoActionCondition (SSkip _) = return True
getNoActionCondition (SLabel _ _ _ Nothing) = return True
getNoActionCondition (SCall _ _ _ _) = return False
getNoActionCondition (SPar _ Nil) = return True
getNoActionCondition (SPar _ (Cons st Nil)) = getNoActionCondition st
getNoActionCondition (SPar _ _) = return False
getNoActionCondition (SFor _ (SAction _p_init _a_init _) _ _ _) = return False
getNoActionCondition st =
    do x <- stmtTToString st
       messageM ("Case: " +++ x)
       error "unhandled case"

-- #############################################################################
-- #
-- #############################################################################

stmtFTToString :: (Monad m) => (StmtFT a) -> m String
stmtFTToString (SFAction p num _ _ _ (Just Default) _) = return ("[Default Action " +++ (integerToString num) +++ " " +++ (getPIString p) +++ "]")
stmtFTToString (SFAction p num _ _ _ (Just Wait) _) = return ("[Wait Action " +++ (integerToString num) +++ " " +++ (getPIString p) +++ "]")
stmtFTToString (SFAction p num _ _ _ (Just (Jump label)) _) = return ("[Jump Action " +++ (integerToString num) +++ " " +++ (getPIString p) +++ " " +++ label +++ "]")
stmtFTToString (SFAction p num _ _ _ _ _) = return ("[Action " +++ (integerToString num) +++ " " +++ (getPIString p) +++ "]")
stmtFTToString (SFIf1 p _ st)  =
    do sub <- stmtFTToString st
       return ("[If1" +++(getPIString p)+++ " " +++ sub +++ "]")
stmtFTToString (SFIf2 p _ s0 s1)  =
    do sub0 <- stmtFTToString s0
       sub1 <- stmtFTToString s1
       return ("[If2" +++(getPIString p)+++ " " +++ sub0 +++ " " +++ sub1 +++ "]")
stmtFTToString (SFSeq p ss) =
    do subs <- stmtFTListToString ss
       return ("[Seq" +++(getPIString p)+++ " " +++ subs +++ "]")
stmtFTToString (SFPar p _ ss) =
    do subs <- stmtTListToString ss
       return ("[Par" +++ (getPIString p) +++ " " +++ subs +++ "]")
stmtFTToString (SFSkip p) = return ("[Skip" +++(getPIString p)+++ "]")
stmtFTToString (SFLabel p name _ Nothing) = return ("[Label " +++ name +++ " " +++(getPIString p)+++ "]")
stmtFTToString (SFReturn p) = return ("[Return" +++(getPIString p)+++ "]")
-- stmtFTToString (SFBreak p) = return ("[Break" +++(getPIString p)+++ "]")
-- stmtFTToString (SFContinue p) = return ("[Continue" +++(getPIString p)+++ "]")
stmtFTToString (SFWhile p _ st) =
    do sub <- stmtFTToString st
       return ("[While" +++(getPIString p)+++ " " +++ sub +++ "]")
stmtFTToString (SFFor p s1 _ s2 s3) =
    do x1 <- stmtFTToString s1
       x2 <- stmtFTToString s2
       x3 <- stmtFTToString s3
       return ("[SFor" +++(getPIString p)+++ " " +++ x1 +++ " " +++ x2 +++ " " +++ x3 +++ "]")
stmtFTToString (SFNamed p nm Nil)  =
    return ("[SFNamed " +++ nm +++ (getPIString p)+++ "]")
stmtFTToString (SFNamed p nm (Cons st Nil)) =
    do sub <- stmtFTToString st
       return ("[SNamed " +++ nm +++ (getPIString p)+++ " [" +++ sub +++ "]]")
stmtFTToString (SFUntil _ _) = return ("[SFUntil]")
stmtFTToString _ = return "XXXX"
stmtFTToString _ = error "unhandled case"

stmtFTListToString :: (Monad m) => (List (StmtFT a)) -> m String
stmtFTListToString x =
    do y <- stmtFTListToStringInternal x
       return ("(" +++ y +++ ")")

stmtFTListToStringInternal :: (Monad m) => (List (StmtFT a)) -> m String
stmtFTListToStringInternal Nil = return ""
stmtFTListToStringInternal (Cons x Nil) = stmtFTToString x
stmtFTListToStringInternal (Cons x rest) =
    do y <- stmtFTToString x
       z <- stmtFTListToStringInternal rest
       return (y +++ " " +++ z)


integerListToString :: (Monad m) => (List Integer) -> m String
integerListToString x =
    do y <- integerListToStringInternal x
       return ("(" +++ y +++ ")")

integerListToStringInternal :: (Monad m) => (List Integer) -> m String
integerListToStringInternal Nil = return ""
integerListToStringInternal (Cons x Nil) = return (integerToString x)
integerListToStringInternal (Cons x rest) =
    do let y = integerToString x
       z <- integerListToStringInternal rest
       return (y +++ " " +++ z)


-- #############################################################################
-- #
-- #############################################################################

-- #############################################################################
-- # Pipe abort signal to sub_fsms
-- #############################################################################

mkModFromStmtFT :: (IsModule m c) => Bool -> Bool -> (StmtFT a) -> m FSMAbort

mkModFromStmtFT _in_par _in_loop (SFAction _ _ _ a_abort _ _ _) =
      module
        interface FSMAbort
            abort = a_abort

mkModFromStmtFT in_par in_loop (SFSeq _ (Cons st Nil)) =
      mkModFromStmtFT in_par in_loop st

mkModFromStmtFT in_par in_loop (SFSeq p (Cons st ss)) =
    module
        _mod0 <- mkModFromStmtFT in_par in_loop st
        _mod1 <- mkModFromStmtFT in_par in_loop (SFSeq p ss)
        interface FSMAbort
            abort = action {_mod0.abort; _mod1.abort}

mkModFromStmtFT in_par in_loop (SFIf1 _ _ s0) =
      mkModFromStmtFT in_par in_loop s0

mkModFromStmtFT in_par in_loop (SFIf2 _ _ s0 s1) =
    module
        _mod0 <- mkModFromStmtFT in_par in_loop s0
        _mod1 <- mkModFromStmtFT in_par in_loop s1
        interface FSMAbort
            abort = action {_mod0.abort; _mod1.abort}

mkModFromStmtFT _in_par _in_loop (SFSkip _) =
    module
        interface FSMAbort
            abort = noAction

mkModFromStmtFT _in_par _in_loop (SFLabel _ _ _ _) =
    module
        interface FSMAbort
            abort = noAction

mkModFromStmtFT _in_par _in_loop (SFReturn _) =
    module
        interface FSMAbort
            abort = noAction

mkModFromStmtFT _in_par _in_loop (SFNamed _ _ Nil) =
    module
        interface FSMAbort
            abort = noAction

mkModFromStmtFT in_par in_loop (SFNamed _ _ (Cons st Nil)) =
      mkModFromStmtFT in_par in_loop st

mkModFromStmtFT _in_par _in_loop (SFUntil _ _) =
    module
        interface FSMAbort
            abort = noAction

mkModFromStmtFT _in_par _in_loop (SFWhile _ _ st) =
    mkModFromStmtFT False True st

mkModFromStmtFT _ _ st =
    do x <- stmtFTToString st
       messageM ("Case: " +++ x)
       error "unhandled case"

-- #############################################################################
-- #
-- #############################################################################

mkFSM :: (IsModule m c) => Stmt -> m FSM
mkFSM (S st) = mkFSMWithPred (S st) True

mkAlwaysFSM :: (IsModule m c) => Stmt -> m Empty
mkAlwaysFSM (S st) = mkAlwaysFSMWithPred (S st) True


mkFSMWithPred1 :: (IsModule m c) => Stmt -> Bool -> m FSM
mkFSMWithPred1 (S st) pred =
    module
        _rfsm :: RFSM (Bit 0)
        _rfsm <- mkRFSM (S st) pred False (createDummyPut)

        let cond = _rfsm.ready
        return $
            interface FSM
                start =  _rfsm.start
                done = cond
                waitTillDone = noAction when cond
                abort = _rfsm.abort

mkFSMWithPred :: (IsModule m c) => Stmt -> Bool -> m FSM
mkFSMWithPred (S st) pred =
    module
        start_reg :: Reg(Bool)
        start_reg <- mkReg False

        _rfsm :: RFSM (Bit 0)
        _rfsm <- mkRFSM (S st) pred False (createDummyPut)

        let cond = _rfsm.ready && (not start_reg)
--        let cond = _rfsm.ready

        rules {"fsm_start": when start_reg
                          ==> action { _rfsm.start;
                                       start_reg := False }}
        return $
            interface FSM
                start = action { start_reg := True } when cond
--                start =  _rfsm.start
                done = cond
                waitTillDone = noAction when cond
                abort = _rfsm.abort


mkAlwaysFSMWithPred :: (IsModule m c) => Stmt -> Bool -> m Empty
mkAlwaysFSMWithPred (S st) pred =
    module

        _rfsm :: RFSM (Bit 0)
        _rfsm <- mkRFSM (S st) pred True (createDummyPut)

mkAutoFSM :: (IsModule m c) => Stmt -> m Empty
mkAutoFSM stmts =
    module
        _test_fsm <- mkFSM stmts
        running <- mkReg False
        rules {"auto_start" : when (not running)
                              ==> action { _test_fsm.start; running := True }}
        rules {"auto_finish" : when (running && _test_fsm.done)
                               ==> $finish 0}

-- #############################################################################
-- #
-- #############################################################################

mkFSMServer :: (IsModule m c, Bits a sa, Bits b sb, Eq a) => (a -> (RStmt b)) -> m (FSMServer a b)
mkFSMServer stmt_func =
    module

        enabled :: Reg Bool
        enabled <- mkReg(True)

        fifo_in :: FIFO a
        fifo_in <- mkTurboFIFO

        fifo_out :: FIFO b
        fifo_out <- mkTurboFIFO

        let ifc_put = interface Put
                           put x = action { fifo_out.enq(x); enabled := False }

        _rfsm :: RFSM b
        _rfsm <- mkRFSM (stmt_func fifo_in.first) (fifo_in.first == fifo_in.first) False ifc_put

        rules {"fsm_start": when enabled
               ==> action { _rfsm.start }}

        let ifc_server = interface Server
                             request  = toPut fifo_in
                             response =
                                 interface Get
                                     get = do
                                            fifo_in.deq
                                            fifo_out.deq
                                            enabled := True
                                            return fifo_out.first
        return $
            interface FSMServer
                server   = ifc_server
                abort    = action {fifo_in.clear;
                                   fifo_out.clear;
                                   enabled := True;
                                   _rfsm.abort }


-- #############################################################################
-- #
-- #############################################################################

mkRFSM :: (IsModule m c, Bits a sa) => (RStmt a) -> Bool -> Bool -> (Put a) -> m (RFSM a)
mkRFSM st pred always ifc =
    module
       (r, ifc') <- mkRFSMNR pred False always ifc st
       addRules r
       return ifc'

mkRFSMNR  :: (IsModule m c, Bits a sa) => Bool -> Bool -> Bool -> (Put a) -> RStmt a -> m (Rules, (RFSM a))
mkRFSMNR pred in_par always ifc ss =
    module
        (rs, ifc') <- mkRFSMNRS pred in_par always ifc ss
        return ((rJoin rs.me_local (rJoin rs.me_parents rs.no_me)), ifc')

mkRFSMNRS  :: (IsModule m c, Bits a sa) => Bool -> Bool -> Bool -> (Put a) -> RStmt a -> m (RuleSet, (RFSM a))
mkRFSMNRS pred in_par always ifc (S st) =
    module
        (_, ss) <- liftModule st

        mkRFSMNR0 pred in_par always ifc ss

mkRFSMNR0  :: (IsModule m c, Bits a sa) => Bool -> Bool -> Bool -> (Put a) -> RStmts a -> m (RuleSet, (RFSM a))
-- mkRFSMNR0 pred in_par always ifc (Cons (SSeq ps Nil))


mkRFSMNR0 _pred _in_par _always _ifc (Cons (SSeq _ Nil) Nil) =
    module
       start_wire :: Wire(Bool)
       start_wire <- mkDWire False
       let ifc = interface RFSM
                    start = action { start_wire := True }
                    abort = dummyAction
                    ready = True
       return (emptyRuleSet, ifc)

mkRFSMNR0 pred in_par always ifc (Cons (SSeq _ (Cons x Nil)) Nil) =
    mkRFSMNR0 pred in_par always ifc (Cons x Nil)


mkRFSMNR0 pred _in_par always _ifc (Cons (SAction p a Nothing) Nil) =
     module

       let l = getPIString p
       start_wire :: Wire(Bool)
       start_wire <- mkDWire False

       start_reg :: Wire(Bool)
       start_reg <- mkDReg False

       abort :: Wire(Bool)
       abort <- mkDWire False

       fired :: Wire(Bool)
       fired <- mkDReg False

       let start = if (always) then True else start_wire

       let r = rules {{-# aggressive_implicit_conditions #-} (ruleName "action" 1 l): when (start && pred)
                   ==> action {fired := True; a}}

       let do_start = action { start_wire := True; start_reg := True}
       let stalled = start_reg && (not fired);
       let cond_ready = (not stalled)

       rules { "restart": when (stalled && (not abort))
                 ==> do_start }

       let ifc = interface RFSM
                    start = do_start when cond_ready
                    abort = action { abort := True }
                    ready = cond_ready
       let rs = RuleSet {me_local = eR;
                         me_parents = r;
                         no_me = eR}
       return (rs, ifc)

mkRFSMNR0 pred in_par always ifc ss =
    module

        let ps = getStmtTPosInfo (head ss)

        start_wire :: Wire(Bool)
        start_wire <- mkDWire False

        start_reg :: Wire(Bool)
        start_reg <- mkDReg False

        abort :: Wire(Bool)
        abort <- mkDWire False





        let init_state = idle_state;
        let return_label = "__return__"

        let no_action = (SAction ps noAction Nothing)

        (seq_labelled , ls) <- labelActions (SSeq ps (append (Cons (SLabel ps return_label False Nothing) (Cons (SUntil ps True) ss)) (Cons (SJump ps return_label) (Cons no_action Nil))))
                                                    (initLabelState init_state return_label ifc)

        let start = if (always) then True else start_wire

        state <- mkState (ls.state_num - 1) start abort

        let do_start = action { start_wire := True; start_reg := True }

        _seq_final' <- attachNames seq_labelled
        _seq_final  <- removePars pred _seq_final'

        let seq_0 = _seq_final

        -- #############################################################################
        -- #
        -- #############################################################################

        (seq, tsds_runx) <- getRefinedTSDs False True  start seq_0
        (_,   tsds_cndx) <- getRefinedTSDs False False True  seq_0

        let tsds_run  = combineTSDs (sortBy compareTSDs tsds_runx)
        let tsds_cndy = combineTSDs (sortBy compareTSDs tsds_cndx)

        y <- stmtFTToString seq
--        messageM("G: " +++ y)

        tsds_cnd <- addNoActionState tsds_cndy ls

        let per_action_tsds = groupBy matchingTSDs tsds_run

        pairs  <- mapM (createRulesForTSDs seq state pred) per_action_tsds
        let rr =  foldr1 combineRuleSets pairs
--        let rr = rJoinME pairs

        -- this means the first action in the fsm blocked
        let stalled = start_reg && (not state.fired_last)

        cond_ready0 <- createReadyCond tsds_cnd state
        let cond_ready = cond_ready0 && (not stalled)

        rules { "restart": when (stalled && (not abort))
                 ==> do_start }

        _mod  <- mkModFromStmtFT in_par False seq

        let ifc' = interface RFSM
                    start = do_start when cond_ready
                    abort = action { abort := True }
                    ready  = cond_ready
        return (rr, ifc')

-- #############################################################################
-- #
-- #############################################################################

createDummyPut :: Put a
createDummyPut = interface Put
                     put _ = noAction

-- #############################################################################
-- #
-- #############################################################################

getRefinedTSDs :: (Monad m) => Bool -> Bool -> Bool -> (StmtFT a) -> m ((StmtFT a), TwoStateDescriptors)
getRefinedTSDs allow_open do_warn start seq =
     do let not_false  (TSD cond _ _ _) = not (isStaticAndFalse cond)
        (seq', _) <- addNextStateDescriptors seq Nil
        l         <- collectLabelNSDs seq'
        lseq      <- addLabelNSDs allow_open l seq'
        ws        <- getWaitActions lseq
        js        <- getJumpActions lseq
        os        <- getUpdateOverlapActions lseq
        es        <- getUpdateEarlyActions lseq
        -- messageM("WS: " +++ toString (length ws) +++ " JS: " +++ toString js +++ " OS: " +++ toString (length os) +++ " ES: " +++ toString (length es))


        zzz0      <- collectTSDs allTSDs start lseq
        let zzz0_r = (filter not_false zzz0)
        zzz0a     <- addAllOvlpUpdateBypassTSDs os zzz0_r
        let zzz0a_r = combineTSDs (sortBy compareTSDs (filter not_false zzz0a))
        zzz1      <- addAllJumpBypassTSDs js zzz0a_r
        let zzz1_r = combineTSDs (sortBy compareTSDs (filter not_false zzz1))
        zzz3      <- addAllWaitBypassTSDs ws zzz1_r
        (lseq', zzz4) <- addAllEarlyUpdateBypassTSDs es (lseq, zzz3) do_warn

        return (lseq', zzz4)

-- #############################################################################
-- #
-- #############################################################################

createReadyCond :: (Monad m) => TwoStateDescriptors -> State -> m Bool
createReadyCond all_tsds state =
          do let is_start (TSD _ _ _ Start) = True
                 is_start _                 = False
                 tsds = filter is_start all_tsds
             let getCond (TSD cond f _ _) = cond && state.is f
             let cond = (fold (||) (map getCond tsds))
             return (cond);

-- #############################################################################
-- #
-- #############################################################################

createLabeledStmtFT :: (IsModule m c) => (StmtT a) -> (LabelState a) -> m ((StmtFT a), (LabelState a))
createLabeledStmtFT = labelActions

-- #############################################################################
-- #
-- #############################################################################

removePars :: (IsModule m c, Bits a sa) => Bool -> (StmtFT a) -> m (StmtFT a)
removePars _pred st@(SFAction _ _ _ _ _ _ _) = return st

removePars pred (SFIf1 p c s1) =
    do _r <- removePars pred s1
       return (SFIf1 p c _r)

removePars pred (SFIf2 p c s0 s1) =
    do _r0 <- removePars pred s0
       _r1 <- removePars pred s1
       return (SFIf2 p c _r0 _r1)

removePars pred (SFSeq p (Cons st Nil)) =
    do _r <- removePars pred st
       return (SFSeq p (Cons _r Nil))

removePars pred (SFSeq p (Cons st ss)) =
    do _r  <- removePars pred st
       _rr <- removePars pred (SFSeq p ss)
       return (SFSeq p (Cons _r (getStmtFTList _rr)))

removePars pred (SFPar p (SFAction _ num _ _ a _ _) ss) =
    do par_running :: Wire(Bool)
       par_running <- mkDWire False
       let zzz = pred && par_running
       par_blocks <- mapM (mkRFSMNRS zzz True False (createDummyPut)) (map _s__ ss)
       -- reverse par_blocks for consistency with prev versions
       let (r_list, fsm_list) = unzip (reverse par_blocks)
--           rs = fold rJoin r_list
           rs = (foldr1 mergeRuleSets r_list)
           modAbort :: RFSM a -> Action
           modAbort ifc = ifc.abort
           modStart :: RFSM a -> Action
           modStart ifc = ifc.start
           modReady :: RFSM a -> Bool
           modReady ifc = ifc.ready
           a_abort = (joinActions (map modAbort fsm_list))
           label   = ("__par_start__" +++ (integerToString num))
           seq = (SFSeq p (Cons
                           (SFAction ("par_start" +++ p) num Nil a_abort action {joinActions (map modStart fsm_list);
                                                                      a;
                                                                      par_running := True;
                                                                      -- $display "(%0d) starting pars" $time;
                                                                       } nAT (Just rs))
                              (Cons (SFLabel p label Nil Nothing)
                                (Cons (SFIf1 p (not (and (map modReady fsm_list)))
                                               (SFSeq p
                                                (Cons  (SFAction ("par_run" +++ p) (num+1) Nil noAction action { par_running := True;} (Just NoME)         nR)
                                                 (Cons (SFAction p             (num+2) Nil noAction noAction                   (Just (Jump label)) nR) Nil)))) Nil))))
       return seq

removePars _pred st@(SFSkip _)     = return st
removePars _pred st@(SFReturn _)   = return st
removePars _pred st@(SFLabel _ _ _ Nothing) = return st
removePars pred (SFNamed p name ss) =
    do rr <- mapM (removePars pred) ss
       return (SFNamed p name rr)
removePars _ st@(SFUntil _ _)  = return st

removePars pred (SFWhile p c st) =
    do _r <- removePars pred st
       return (SFWhile p c _r)

removePars _pred st =
    do x <- stmtFTToString st
       messageM ("Case: " +++ x)
       error "unhandled case"

-- #############################################################################
-- #
-- #############################################################################

attachNames :: (IsModule m c) => (StmtFT a) -> m (StmtFT a)
attachNames st@(SFAction _ _ _ _ _ _ _) = return st

attachNames (SFIf1 p c st) =
    do _r <- attachNames st
       return (SFIf1 p c _r)

attachNames (SFIf2 p c s0 s1) =
    do _r0 <- attachNames s0
       _r1 <- attachNames s1
       return (SFIf2 p c _r0 _r1)

attachNames (SFSeq p ss) =
    do _rr <- mapM attachNames ss
       let _ss = listAttachNames _rr
       return (SFSeq p _ss)

attachNames st@(SFPar _ _ _) =
    return st

attachNames st@(SFSkip _)     = return st
attachNames st@(SFReturn _)   = return st
attachNames st@(SFLabel _ _ _ Nothing) = return st
attachNames (SFNamed p name ss) =
  do rr <- mapM attachNames ss
     return (SFNamed p name rr)
attachNames st@(SFUntil _ _) = return st

attachNames (SFWhile p c st) =
    do _r <- attachNames st
       return (SFWhile p c _r)

attachNames st =
    do x <- stmtFTToString st
       messageM ("Case: " +++ x)
       error "unhandled case"

-- #############################################################################
-- #
-- #############################################################################

listAttachNames :: (List (StmtFT a)) -> (List (StmtFT a))
listAttachNames Nil          = Nil
listAttachNames st@(Cons _ Nil) = st
listAttachNames (Cons (SFNamed p name Nil) (Cons st@(SFSeq _ _) rest)) =
   (Cons (SFNamed p name (Cons st Nil)) (listAttachNames rest))
listAttachNames (Cons (SFNamed p name Nil) (Cons st@(SFPar _ _ _) rest)) =
   (Cons (SFNamed p name (Cons st Nil)) (listAttachNames rest))
listAttachNames (Cons st rest) =
   (Cons st (listAttachNames rest))

-- #############################################################################
-- #
-- #############################################################################

addActionAt :: (Monad m) => Action -> Integer -> (StmtFT a) -> m (StmtFT a)
addActionAt a n st@(SFAction p na nsd a_abort a_body at rs) =
         do let a_combined = joinActions (Cons a_body (Cons a Nil))
            if (n == na) then return (SFAction p n nsd a_abort a_combined at rs)
                         else return st

addActionAt a n (SFIf1 p c s1) =
    do _r <- addActionAt a n s1
       return (SFIf1 p c _r)

addActionAt a n (SFIf2 p c s0 s1) =
    do _r0 <- addActionAt a n s0
       _r1 <- addActionAt a n s1
       return (SFIf2 p c _r0 _r1)

addActionAt a n (SFSeq p ss) =
    do _ss <- mapM (addActionAt a n) ss
       return (SFSeq p _ss)

addActionAt _ _ st@(SFSkip _)     = return st
addActionAt _ _ st@(SFReturn _)   = return st
addActionAt _ _ st@(SFLabel _ _ _ Nothing) = return st
addActionAt _ _ st@(SFUntil _ _) = return st
addActionAt a n (SFNamed p name ss) =
  do _ss <- mapM (addActionAt a n) ss
     return (SFNamed p name _ss)

addActionAt a n (SFWhile p c st) =
    do _r <- addActionAt a n st
       return (SFWhile p c _r)

addActionAt _ _ st =
    do x <- stmtFTToString st
       messageM ("Case: " +++ x)
       error "unhandled case"

getAction :: (Monad m) => Integer -> (StmtFT a) -> m Action
getAction n (SFAction _ na _nsd _a_abort a_body _at _rs) =
         do if (n == na) then return a_body else return noAction

getAction n (SFIf1 _ _ s1) = getAction n s1

getAction n (SFIf2 _ _ s0 s1) =
    do a0 <- getAction n s0
       a1 <- getAction n s1
       return (joinActions (Cons a0 (Cons a1 Nil)))

getAction n (SFSeq _ ss) =
    do as <- mapM (getAction n) ss
       return (joinActions as)

getAction _ (SFSkip _)     = return noAction
getAction _ (SFReturn _)   = return noAction
getAction _ (SFLabel _ _ _ Nothing) = return noAction
getAction n (SFNamed _ _ ss) =
  do as <- mapM (getAction n) ss
     return (joinActions as)

getAction n (SFWhile _ _ st) =
    do a <- getAction n st
       return a

getAction _ st =
    do x <- stmtFTToString st
       messageM ("Case: " +++ x)
       error "unhandled case"

-- #############################################################################
-- #
-- #############################################################################

collectLabelNSDs :: (Monad m) => (StmtFT a) -> m (List (String, NextStateDescriptors))
collectLabelNSDs (SFAction _ _ _ _ _ _ _) =
   return Nil
collectLabelNSDs (SFIf1 _ _ s1) =
   collectLabelNSDs s1
collectLabelNSDs (SFIf2 _ _ s0 s1) =
   do c0 <- (collectLabelNSDs s0)
      c1 <- (collectLabelNSDs s1)
      return (append c0 c1)
-- TTTT
collectLabelNSDs (SFPar _ _ _) =
   return Nil
collectLabelNSDs (SFSeq _ ss) =
   do x <- mapM collectLabelNSDs ss
      return (concat x)
collectLabelNSDs (SFSkip _) =
   return Nil
collectLabelNSDs (SFReturn _) =
   return Nil
collectLabelNSDs (SFLabel _ name nsd Nothing) =
   return (Cons (name, nsd) Nil)
collectLabelNSDs (SFNamed _ _ ss) =
   do x <- mapM collectLabelNSDs ss
      return (concat x)
collectLabelNSDs (SFUntil _ _) =
   return Nil

collectLabelNSDs (SFWhile _ _ st) =
    do x <- collectLabelNSDs st
       return x

collectLabelNSDs st =
   do x <- stmtFTToString st
      messageM ("Case: " +++ x)
      error "unhandled case"

addLabelNSDs :: (Monad m) => Bool -> (List (String, NextStateDescriptors)) -> (StmtFT a) -> m (StmtFT a)
addLabelNSDs allow_open lbls (SFAction p n _ a_abort a (Just (Jump label)) rs) =
   do let m_nsd = getLabelNSDs allow_open label lbls
          pos = getStringPosition label
          msg = setStringPosition ("No Label '" +++ label +++ "' found for goto.") pos
          xx (Just nsd) = nsd
          xx _          = error msg
      return (SFAction p n (xx m_nsd) a_abort a (Just (Jump label)) rs)
addLabelNSDs _allow_open _lbls st@(SFAction _ _ _ _ _ _ _) =
   return st
addLabelNSDs allow_open lbls (SFIf1 p c s1) =
   do s' <- addLabelNSDs allow_open lbls s1
      return (SFIf1 p c s')
addLabelNSDs allow_open lbls (SFIf2 p c s0 s1) =
   do s0' <- (addLabelNSDs allow_open lbls s0)
      s1' <- (addLabelNSDs allow_open lbls s1)
      return (SFIf2 p c s0' s1')
addLabelNSDs _allow_open _lbls st@(SFPar _ _ _) =
   return st
addLabelNSDs allow_open lbls (SFSeq p ss) =
   do ss' <- mapM (addLabelNSDs allow_open lbls) ss
      return (SFSeq p ss')
addLabelNSDs _allow_open _lbls st@(SFSkip _) =
   return st
addLabelNSDs _allow_open _lbls st@(SFReturn _) =
   return st
addLabelNSDs _allow_open _lbls st@(SFLabel _ _ _ Nothing) =
   return st
addLabelNSDs allow_open lbls (SFNamed p n ss) =
   do ss' <- mapM (addLabelNSDs allow_open lbls) ss
      return (SFNamed p n ss')
addLabelNSDs _allow_open _lbls st@(SFUntil _ _) =
   return st

addLabelNSDs allow_open lbls (SFWhile p c st) =
    do _r <- addLabelNSDs allow_open lbls st
       return (SFWhile p c _r)

addLabelNSDs _allow_open _lbls st =
   do x <- stmtFTToString st
      messageM ("Case: " +++ x)
      error "unhandled case"

getLabelNSDs :: Bool -> String -> (List (String, NextStateDescriptors)) -> (Maybe NextStateDescriptors)
getLabelNSDs True  _ Nil = Just Nil
getLabelNSDs False _ Nil = Nothing
getLabelNSDs allow_open name (Cons (l, nsd) rest) = if (name == l) then (Just nsd) else getLabelNSDs allow_open name rest

-- #############################################################################
-- #
-- #############################################################################

getJumpActions :: (Monad m) => (StmtFT a) -> m (List Integer)
getJumpActions st = collectActions (Just (Jump "")) st

getUpdateEarlyActions :: (Monad m) => (StmtFT a) -> m (List Integer)
getUpdateEarlyActions st = collectActions (Just (Update (Early ""))) st

getUpdateOverlapActions :: (Monad m) => (StmtFT a) -> m (List Integer)
getUpdateOverlapActions st = collectActions (Just (Update Overlap)) st

getWaitActions :: (Monad m) => (StmtFT a) -> m (List Integer)
getWaitActions st = collectActions (Just Wait) st

-- #############################################################################
-- #
-- #############################################################################

collectActions :: (Monad m) => (Maybe ActionType) -> (StmtFT a) -> m (List Integer)
collectActions at (SFAction _ n _ _ _ x _) =
   return (if (actionTypesMatch at x) then (Cons n Nil) else Nil)
collectActions _ (SFAction _ _ _ _ _ _ _) =
   return Nil
collectActions at (SFIf1 _ _ s1) =
   collectActions at s1
collectActions at (SFIf2 _ _ s0 s1) =
   do c0 <- (collectActions at s0)
      c1 <- (collectActions at s1)
      return (append c0 c1)
collectActions at (SFPar _ r _) =
   collectActions at r

collectActions at (SFSeq _ ss) =
   do x <- mapM (collectActions at) ss
      return (concat x)
collectActions _ (SFSkip _) =
   return Nil
collectActions _ (SFReturn _) =
   return Nil
collectActions _ (SFLabel _ _ _ _) =
   return Nil
collectActions at (SFNamed _ _ ss) =
   do x <- mapM (collectActions at) ss
      return (concat x)
collectActions _ (SFUntil _ _) =
   return Nil

collectActions at (SFWhile _ _ st) =
   do x <- collectActions at st
      return x

collectActions _ st =
   do x <- stmtFTToString st
      messageM ("Case: " +++ x)
      error "unhandled case"

labelsMatch :: Integer -> Integer -> Bool
labelsMatch 0 _ = True
labelsMatch _ 0 = True
labelsMatch a b = (a == b)

actionTypesMatch :: (Maybe ActionType) -> (Maybe ActionType) -> Bool
actionTypesMatch (Just (Jump _)) (Just (Jump _)) = True
actionTypesMatch (Just (Update (Early _))) (Just (Update (Early _))) = True
actionTypesMatch a b = (a == b)

-- #############################################################################
-- #
-- #############################################################################

collectTSDs :: (Monad m) => (Integer -> Integer -> Bool) -> Bool -> (StmtFT a) -> m TwoStateDescriptors
collectTSDs f start (SFAction _ n nsd _ _ _ _) =
   return (concat (map (createTSD n f start) nsd))
collectTSDs f start (SFIf1 _ _ s1) =
   collectTSDs f start s1
collectTSDs f start (SFIf2 _ _ s0 s1) =
   do c0 <- (collectTSDs f start s0)
      c1 <- (collectTSDs f start s1)
      return (append c0 c1)
-- TTTT
collectTSDs f start (SFPar _ r _) =
   collectTSDs f start r
collectTSDs f start (SFSeq _ ss) =
   do x <- mapM (collectTSDs f start) ss
      return (concat x)
collectTSDs _ _ (SFSkip _) =
   return Nil
collectTSDs _ _ (SFReturn _) =
   return Nil
collectTSDs _ _ (SFLabel _ _ _ Nothing) =
   return Nil
collectTSDs f start (SFNamed _ _ ss) =
   do x <- mapM (collectTSDs f start) ss
      return (concat x)
collectTSDs _ _ (SFUntil _ _) =
   return Nil

collectTSDs f start (SFWhile _ _ st) =
   do x <- collectTSDs f start st
      return x

collectTSDs _ _ st =
   do x <- stmtFTToString st
      messageM ("Case: " +++ x)
      error "unhandled case"

createTSD :: Integer -> (Integer -> Integer -> Bool) -> Bool -> NextStateDescriptor -> (List TwoStateDescriptor)
createTSD num f start (cond, i) =
   let kind = if (num == idle_state)    then Start
              else if (i == idle_state) then End
              else                           Default
       c    = if (num == idle_state) then cond && start else cond
   in if (f num i) then (Cons (TSD c num i kind) Nil) else Nil


combineTSDs :: TwoStateDescriptors -> TwoStateDescriptors
combineTSDs (Cons a@(TSD conda fa ta ka) (Cons b@(TSD condb fb tb kb) rest)) =
--       if      (isStaticAndFalse conda)   then combineTSDs (Cons b rest)
--       else if (isStaticAndFalse condb)   then combineTSDs (Cons a rest)
--       else if ((fa == fb) && (ta == tb) && (ka == kb))
       if ((fa == fb) && (ta == tb) && (ka == kb))
                                          then combineTSDs (Cons (TSD (conda || condb) fa ta ka) rest)
       else                                    (Cons a (combineTSDs (Cons b rest)))
combineTSDs (Cons a@(TSD _ _ _ _) Nil) = (Cons a Nil)
combineTSDs Nil = Nil


allTSDs :: Integer -> Integer -> Bool
allTSDs _ _ = True

exactTSDs :: Integer -> Integer -> Integer -> Integer -> Bool
exactTSDs m n f t = (m == f) && (n == t)

toNTSDs :: Integer -> Integer -> Integer -> Bool
toNTSDs n _ m = n == m

fromNTSDs :: Integer -> Integer -> Integer -> Bool
fromNTSDs n m _ = n == m

startTSDs :: Integer -> Integer -> Bool
startTSDs f t = (toNTSDs idle_state f t) || (fromNTSDs idle_state f t)

-- #############################################################################
-- #
-- #############################################################################

addAllWaitBypassTSDs :: (Monad m) => (List Integer) -> TwoStateDescriptors -> m TwoStateDescriptors
addAllWaitBypassTSDs Nil tsds = return tsds
addAllWaitBypassTSDs (Cons n rest) tsds =
    do x <- addAllWaitBypassTSDs rest tsds
       addWaitBypassTSDs n x

addWaitBypassTSDs :: (Monad m) => Integer -> TwoStateDescriptors -> m TwoStateDescriptors
addWaitBypassTSDs n tsds =
  do let self (TSD _cond f t _) = t == n && f == n
         to   (TSD _cond f t _) = t == n && (not (f == n))
         from (TSD _cond f t _) = f == n && (not (t == n))
         rest (TSD _cond f t _) = not (t == n) || (f == t)
         self_list = filter self tsds
         to_list   = filter to   tsds
         from_list = filter from tsds
         rest_list = filter rest tsds
         getCond (TSD c _ _ _) = c
         any_out = foldr1 (||) (map getCond from_list)
         create_bypass (TSD cond_in f0 t0 k0) (TSD cond_out _f1 t1 k1) =
                     (Cons (TSD (cond_in && cond_out) f0 t1 (combineTSDTypes k0 k1))
                           (Cons (TSD (cond_in && (not any_out)) f0 t0 k0) Nil))
         create_bypasses tsd = concat (map (create_bypass tsd) from_list)
     return (append (append (concat (map create_bypasses to_list)) self_list) rest_list)



addAllJumpBypassTSDs :: (Monad m) => (List Integer) -> TwoStateDescriptors -> m TwoStateDescriptors
addAllJumpBypassTSDs Nil tsds = return tsds
addAllJumpBypassTSDs (Cons n rest) tsds =
    do x <- addAllJumpBypassTSDs rest tsds
       addJumpBypassTSDs n x

addJumpBypassTSDs :: (Monad m) => Integer -> TwoStateDescriptors -> m TwoStateDescriptors
addJumpBypassTSDs n tsds =
  do let self (TSD _cond f t _) = t == n && f == n
         to   (TSD _cond f t _) = t == n && (not (f == n))
         from (TSD _cond f t _) = f == n && (not (t == n))
         rest (TSD _cond f t _) = not ((t == n) || (f == n))
         not_false  (TSD cond _ _ _) = not (isStaticAndFalse cond)
         self_list = filter self tsds
         to_list   = filter to   tsds
         from_list = filter from tsds
         rest_list = filter rest tsds
         filtered_self = filter not_false self_list
         getCond (TSD c _ _ _) = c
         any_out = foldr1 (||) (map getCond from_list)
     {-# hide #-}
     jj <- if ((length self_list) > 0 && (length filtered_self) > 0)
           then do let create_bypass (TSD cond_in f0 t0 k0) (TSD cond_out _f1 t1 k1) =
                         (Cons (TSD (cond_in && cond_out) f0 t1 (combineTSDTypes k0 k1))
                           (Cons (TSD (cond_in && (not any_out)) f0 t0 k0) Nil))
                       create_bypasses tsd    = concat (map (create_bypass tsd) from_list)
                       zz = (concat (map create_bypasses to_list))
--                       yy = (append (filter not_false (append zz from_list)) filtered_self)
                       yy = (append (filter not_false (combineTSDs (sortBy compareTSDs zz))) filtered_self)
--                   messageM("HHHHH0: " +++ (toString n) +++ " " +++ (twoStateDescriptorsToString filtered_self))
--                   messageM("HHHHH1: " +++ (toString n) +++ " " +++ (twoStateDescriptorsToString yy))
                   return (append yy rest_list)
           else do let create_bypass (TSD cond_in f0 _t0 k0) (TSD cond_out _f1 t1 k1) =
                        (Cons (TSD (cond_in && cond_out) f0 t1 (combineTSDTypes k0 k1)) Nil)
                       create_bypasses tsd = concat (map (create_bypass tsd) from_list)
                       zz = (concat (map create_bypasses to_list))
                       yy = (filter not_false zz)
                   return (append yy rest_list)
     return jj

addJump2BypassTSDs :: (Monad m) => Integer -> TwoStateDescriptors -> m TwoStateDescriptors
addJump2BypassTSDs n tsds =
  do let to   (TSD _cond _ t _) = t == n
         from (TSD _cond f _ _) = f == n
         rest (TSD _cond f t _) = not ((t == n) || (f == n))
         to_list   = filter to   tsds
         from_list = filter from tsds
         rest_list = filter rest tsds
         getCond (TSD c _ _ _) = c
         any_out = foldr1 (||) (map getCond from_list)
         create_bypass (TSD cond_in f0 t0 k0) x@(TSD cond_out _f1 t1 k1) =
                     (Cons (TSD (cond_in && cond_out) f0 t1 (combineTSDTypes k0 k1))
                           (Cons (TSD (cond_in && (not any_out)) f0 t0 k0)
                                 (Cons x Nil)))
         create_bypasses tsd = concat (map (create_bypass tsd) from_list)
     return (append (concat (map create_bypasses to_list)) rest_list)

addAllOvlpUpdateBypassTSDs :: (Monad m) => (List Integer) -> TwoStateDescriptors -> m TwoStateDescriptors
addAllOvlpUpdateBypassTSDs Nil tsds = return tsds
addAllOvlpUpdateBypassTSDs (Cons n rest) tsds =
    do x <- addAllOvlpUpdateBypassTSDs rest tsds
       addOvlpUpdateBypassTSDs n x


addOvlpUpdateBypassTSDs :: (Monad m) => Integer -> TwoStateDescriptors -> m TwoStateDescriptors
addOvlpUpdateBypassTSDs n tsds =
  do let to   (TSD _cond f t _) = t == n && (not (f == n))
         from (TSD _cond f t _) = f == n && (not (t == n))
         to_list   = filter to   tsds
         from_list = filter from tsds
         create_bypass (TSD cond_in f0 _t0 k0) (TSD cond_out _f1 t1 k1) = (Cons (TSD (cond_in && cond_out) f0 t1 (combineTSDTypes k0 k1)) Nil)
         create_bypasses tsd = concat (map (create_bypass tsd) from_list)
     return (append (concat (map create_bypasses to_list)) tsds)

addAllEarlyUpdateBypassTSDs :: (Monad m) => (List Integer) -> (StmtFT a, TwoStateDescriptors) -> Bool -> m (StmtFT a, TwoStateDescriptors)
addAllEarlyUpdateBypassTSDs Nil s_t _ = return s_t
addAllEarlyUpdateBypassTSDs (Cons n rest) s_t do_warn =
    do (s', tsds') <- addAllEarlyUpdateBypassTSDs rest s_t do_warn
       addEarlyUpdateBypassTSDs n (s', tsds') do_warn

addEarlyUpdateBypassTSDs :: (Monad m) => Integer -> (StmtFT a, TwoStateDescriptors) -> Bool -> m (StmtFT a, TwoStateDescriptors)
addEarlyUpdateBypassTSDs n (st, tsds) do_warn =
 do let  to   (TSD _cond f t _) = t == n && (not (f == n))
         from (TSD _cond f t _) = f == n && (not (t == n))
         rest (TSD _cond f t _) = not ((t == n) || (f == n))
         not_false  (TSD cond _ _ _) = not (isStaticAndFalse cond)
         to_list   = filter to   tsds
         from_list = filter from tsds
         rest_list True  = filter rest tsds
         rest_list False = tsds
         create_bypass (TSD cond_in f0 _t0 k0) (TSD cond_out _f1 t1 k1) = (Cons (TSD (cond_in && cond_out) f0 t1 (combineTSDTypes k0 k1)) Nil)
         create_bypasses True  tsd = concat (map (create_bypass tsd) from_list)
         create_bypasses False _ = Nil
         update_list = map getFrom to_list
         get_action (SFAction _ _ _ _ a _ _) = a
         get_comment (SFAction _ _ _ _ _ (Just (Update (Early txt))) _) = txt
    can_update    <- canUpdateEarly tsds n do_warn
    let l  = getSFAction n st
        sa = head l
        update_action = get_action sa
        comment = get_comment sa
        tsds' = filter not_false (append (concat (map (create_bypasses can_update) to_list)) (rest_list can_update))
    s' <- if (can_update) then (foldrM (addActionAt update_action) st update_list) else return st
    let msg = setStringPosition (comment +++ " will require an added cycle.") (getStringPosition comment)
    if (do_warn && (not can_update)) then warningM msg else return ()
    return (s', tsds')


-- #############################################################################
-- #
-- #############################################################################

canUpdateEarly :: (Monad m) => TwoStateDescriptors -> Integer -> Bool -> m Bool
canUpdateEarly tsds n _do_warn =
   do let is_ok (TSD cond _ t _) = (not (t == n)) || (isStaticAndTrue cond)
          ok = foldr1 (&&) (map is_ok tsds)
      return ok

-- #############################################################################
-- #
-- #############################################################################

getTransitionConditions :: (Monad m) => Integer -> State -> (StmtFT a) -> m (List Bool)
getTransitionConditions num state (SFAction _ n nsd _ _ _ _) =
   return (map ((&&) (state.is n)) (getTransitionConditionsForNSDs num nsd))
getTransitionConditions num state (SFIf1 _ _ s1) =
   getTransitionConditions num state s1
getTransitionConditions num state (SFIf2 _ _ s0 s1) =
   do c0 <- (getTransitionConditions num state s0)
      c1 <- (getTransitionConditions num state s1)
      return (append c0 c1)
getTransitionConditions num state (SFSeq _ ss) =
   do x <- mapM (getTransitionConditions num state) ss
      return (concat x)
getTransitionConditions _ _ (SFSkip _) =
   return Nil
getTransitionConditions _ _(SFReturn _) =
   return Nil

getTransitionConditions num state (SFWhile _ _ st) =
   do c <- (getTransitionConditions num state st)
      return c

getTransitionConditions _ _ st =
   do x <- stmtFTToString st
      messageM ("Case: " +++ x)
      error "unhandled case"

getTransitionConditionsForNSDs :: Integer -> NextStateDescriptors -> List Bool
getTransitionConditionsForNSDs _ Nil = Nil
getTransitionConditionsForNSDs num (Cons (cond, i) rest) =
   if (i == num)
      then (Cons cond (getTransitionConditionsForNSDs num rest))
      else (getTransitionConditionsForNSDs num rest)

rJoinME :: List (Rules, Bool) -> Rules
rJoinME pairs =
    let getSimpleRules :: List (Rules, Bool) -> Rules
        getSimpleRules Nil                   = eR
        getSimpleRules (Cons (rule, True) rest) = rJoin rule (getSimpleRules rest)
        getSimpleRules (Cons _         rest) = getSimpleRules rest
        getMERules :: List (Rules, Bool) -> List Rules
        getMERules Nil                    = Nil
        getMERules (Cons (rule, False) rest) = (Cons rule (getMERules rest))
        getMERules (Cons _          rest) = getMERules rest
        r      = getSimpleRules pairs
        r_list = getMERules pairs
--    in  (fold rJoinMutuallyExclusive (Cons r r_list))
    in  (rJoin r (fold rJoinMutuallyExclusive r_list))

createRulesForTSDs ::  (IsModule m c) => (StmtFT a) -> State -> Bool -> TwoStateDescriptors -> m RuleSet
createRulesForTSDs _ _state _pred Nil = return emptyRuleSet
createRulesForTSDs st state pred tsd =
 do let toNSD (TSD cond' f t _) = ((cond' && state.is f), t)
        nsd = map toNSD tsd
        (_,n) = (head nsd)
        l = getSFAction n st
        sa = (head l)
        getSubRules (SFAction _ _ _ _ _ _ Nothing) = emptyRuleSet
        getSubRules (SFAction _ _ _ _ _ _ (Just r)) = r
        overlapAction (SFAction _ _ _ _ _ (Just (Update Overlap)) _) = True
        overlapAction _                                              = False
        noME (SFAction _ _ _ _ _ (Just NoME) _) = True
        noME _                                  = False
        rs = getSubRules sa
--        getFromState (TSD _ f t k) = f
--        from = getFromState (head tsd)
--        many = from == idle_state || n == idle_state
        many = n == idle_state
        cond_list = getTransitionConditionsForNSDs n nsd
        cond = (fold (||) cond_list)
        no_me = (overlapAction sa) || (noME sa)
        rx = if (many) then (fold rJoin (map (createRuleForSFAction sa state pred) cond_list))
                       else (createRuleForSFAction sa state pred cond)
        rss = if (n == idle_state)
              then RuleSet { me_local = eR; me_parents = eR; no_me = rx }
              else if (no_me) then RuleSet { me_local = eR; me_parents = rx; no_me = eR }
                              else RuleSet { me_local = rx; me_parents = eR; no_me = eR }
    return (mergeRuleSets rs rss)

createRuleForSFAction :: (StmtFT a) -> State -> Bool -> Bool -> Rules

createRuleForSFAction (SFAction p n _ _ a (Just (Jump _)) _) _state pred c' =
    let l = getPIString p
        c = pred && c'
        r = if (isStaticAndFalse c)
            then eR
            else rules {{-# aggressive_implicit_conditions #-} (ruleName "action_jump" n l): when (c)
                       ==> action { -- $display "(%0d) executing%s (state %d)" $time l n;
--                                   state.set (0 - 1);
                                   a}}
    in r

createRuleForSFAction (SFAction p n _ _ a (Just (Update Overlap)) _) state pred c' =
    let l = getPIString p
        c = pred && c'
        r = if (isStaticAndFalse c)
            then eR
            else rules {{-# aggressive_implicit_conditions #-} (ruleName "action_ovlp" n l): when (c)
                       ==> action { -- $display "(%0d) executing%s (state %d)" $time l n;
                                   state.overlap;
                                   a}}
    in r

createRuleForSFAction (SFAction p n _ _ a at _) state pred c' =
    let l = getPIString p
        c = pred && c'
        r = if (isStaticAndFalse c)
            then eR
            else if (n == idle_state) then rules {{-# no_warn #-} {-# aggressive_implicit_conditions #-} (ruleName "idle" n l): when (c')
                       ==> action { -- $display "(%0d) executing%s (state %d)" $time l n;
                                    state.set (fromInteger n);
                                    a}}
            else if (at == (Just Wait)) then rules {{-# no_warn #-} {-# aggressive_implicit_conditions #-} (ruleName "wait" n l): when (c)
                       ==> action { -- $display "(%0d) executing%s (state %d)" $time l n;
                                    state.set (fromInteger n);
                                    a}}
            else rules {{-# aggressive_implicit_conditions #-} (ruleName "action" n l): when (c)
                       ==> action { -- $display "(%0d) executing%s (state %d)" $time l n;
                                    state.set (fromInteger n);
                                    a}}
    in r

-- #############################################################################
-- #
-- #############################################################################

getSFAction :: Integer -> (StmtFT a) -> List (StmtFT a)
getSFAction num st@(SFAction _ n _ _ _ _ _) =
   if (n == num) then (Cons st Nil) else Nil
getSFAction num (SFIf1 _ _ s1) =
   getSFAction num s1
getSFAction num (SFIf2 _ _ s0 s1) =
   let l0 = (getSFAction num s0)
       l1 = (getSFAction num s1)
   in (append l0 l1)
getSFAction num (SFSeq _ ss) =
   let x = map (getSFAction num) ss
   in concat x
getSFAction _ (SFSkip _) = Nil
getSFAction _ (SFReturn _) = Nil
getSFAction _ (SFLabel _ _ _ _) = Nil
getSFAction num (SFNamed _ _ ss) =
   let x = map (getSFAction num) ss
   in concat x
getSFAction _ (SFUntil _ _) = Nil
getSFAction num (SFWhile _ _ st) =
    getSFAction num st
getSFAction _ _ = error "unhandled case"

-- #############################################################################
-- #
-- #############################################################################

interface State =
        is  :: Integer -> Bool
        set :: Integer -> Action
        overlap :: Action
        fired_last :: Bool

interface (State' :: # -> *) n =
        is'  :: Integer -> Bool
        set' :: Integer -> Action

mkState :: (IsModule m c) => Integer -> Bool -> Bool -> m State
mkState n start abort =
  if      n < 2     then ffM ((mkState' start abort) :: m(State' 1))
  else if n < 4     then ffM ((mkState' start abort) :: m(State' 2))
  else if n < 8     then ffM ((mkState' start abort) :: m(State' 3))
  else if n < 16    then ffM ((mkState' start abort) :: m(State' 4))
  else if n < 32    then ffM ((mkState' start abort) :: m(State' 5))
  else if n < 64    then ffM ((mkState' start abort) :: m(State' 6))
  else if n < 128   then ffM ((mkState' start abort) :: m(State' 7))
  else if n < 256   then ffM ((mkState' start abort) :: m(State' 8))
  else if n < 512   then ffM ((mkState' start abort) :: m(State' 9))
  else if n < 1024  then ffM ((mkState' start abort) :: m(State' 10))
  else if n < 2048  then ffM ((mkState' start abort) :: m(State' 11))
  else if n < 4096  then ffM ((mkState' start abort) :: m(State' 12))
  else if n < 8192  then ffM ((mkState' start abort) :: m(State' 13))
  else if n < 16384 then ffM ((mkState' start abort) :: m(State' 14))
  else if n < 32768 then ffM ((mkState' start abort) :: m(State' 15))
  else if n < 65536 then ffM ((mkState' start abort) :: m(State' 16))
  else error "FSM too big"

ffM :: (IsModule m c) => m (State' n) -> m(State)
ffM mm =
  module
    {-# hide #-}
    _i <- mm

    set_pw :: PulseWire
    set_pw <- mkPulseWire

    overlap_pw :: PulseWire
    overlap_pw <- mkPulseWireOR

    fired :: Reg Bool
    fired <- mkDReg False

    can_overlap :: Reg Bool
    can_overlap <- mkReg True

    rules {"every": when True
              ==> action { can_overlap := if (set_pw) then True else (if (overlap_pw) then False else can_overlap) }}

    interface
        is      = _i.is'
        set v   = action { if (v >= 0) then _i.set' v else noAction; fired := True; set_pw.send }
        overlap = action { overlap_pw.send } when (can_overlap)
        fired_last = fired

mkState' :: (IsModule m c) => Bool -> Bool -> m (State' n)
mkState' start abort =
  module
    mkFSMstate :: Reg(Bit n)
    mkFSMstate <- mkConfigReg (fromInteger idle_state)

    rules {{-# no_warn #-} "handle_abort": when (abort && (not start))
                      ==> action { mkFSMstate := fromInteger idle_state }}
    let is x = if (abort) then (x == idle_state) else (fromInteger x ==  mkFSMstate)
    interface
      is' n = is n
      set' n =action { mkFSMstate := fromInteger n } when (not (abort && (not start)))

-- #############################################################################
-- #
-- #############################################################################

interface NCount =
        is    :: Nat -> Bool
        reset :: Action
        incr  :: Action

interface (NCount' :: # -> *) n =
        is'    :: Nat -> Bool
        reset' :: Action
        incr'  :: Action

mkNCount' :: (IsModule m c) => m (NCount' n)
mkNCount' =
  module
    {-# hide #-}
    _x :: Reg(Bit n)
    _x <- mkConfigReg 0
    interface
      is'  n = (zExtend n) == _x
      reset' = _x := 0
      incr'  = _x := _x + 1

mkNCountOneHot :: (IsModule m c) => m (NCount' n)
mkNCountOneHot =
  module
    {-# hide #-}
    _x :: Reg(Bit n)
    _x <- mkConfigReg 1
    let zow 0  = ((primSelectFn noPosition _x 0)  == 1)
        zow nn = ((primSelectFn noPosition _x nn) == 1)
        zow mm = ((primSelectFn noPosition _x mm) == 1)
        zow _  = False
    interface
      is'  x = (zow x)
      reset' = _x := 1
      incr'  = _x := _x << 1

zExtend :: (Add n m k) => Bit n -> Bit m;
zExtend value =
    let out :: Bit k;
        out = zeroExtend value
    in  out[(valueOf m) - 1:0]


ffNM :: (IsModule m c) => m (NCount' n) -> m(NCount)
ffNM mm =
  module
    {-# hide #-}
    _i <- mm

    interface
        is    = _i.is'
        reset = _i.reset'
        incr  = _i.incr'

mkNCount :: (IsModule m c) => Bool -> Nat -> m NCount
mkNCount static n =
  if (static)
    then
      if      (n == 1)  then ffNM(mkNCountOneHot :: m(NCount'  1))
      else if (n == 2)  then ffNM(mkNCountOneHot :: m(NCount'  2))
      else if (n == 3)  then ffNM(mkNCountOneHot :: m(NCount'  3))
      else if (n == 4)  then ffNM(mkNCountOneHot :: m(NCount'  4))
      else if (n == 5)  then ffNM(mkNCountOneHot :: m(NCount'  5))
      else if (n == 6)  then ffNM(mkNCountOneHot :: m(NCount'  6))
      else if (n == 7)  then ffNM(mkNCountOneHot :: m(NCount'  7))
      else if (n == 8)  then ffNM(mkNCountOneHot :: m(NCount'  8))
      else if (n == 9)  then ffNM(mkNCountOneHot :: m(NCount'  9))
      else if (n == 10) then ffNM(mkNCountOneHot :: m(NCount' 10))
      else if (n == 11) then ffNM(mkNCountOneHot :: m(NCount' 11))
      else if (n == 12) then ffNM(mkNCountOneHot :: m(NCount' 12))
      else if (n == 13) then ffNM(mkNCountOneHot :: m(NCount' 13))
      else if (n == 14) then ffNM(mkNCountOneHot :: m(NCount' 14))
      else if (n == 15) then ffNM(mkNCountOneHot :: m(NCount' 15))
      else if (n == 16) then ffNM(mkNCountOneHot :: m(NCount' 16))
      else mkNCount False n
    else if n < 2        then ffNM(mkNCount' :: m(NCount' 1))
    else if n < 4        then ffNM(mkNCount' :: m(NCount' 2))
    else if n < 8        then ffNM(mkNCount' :: m(NCount' 3))
    else if n < 16       then ffNM(mkNCount' :: m(NCount' 4))
    else if n < 32       then ffNM(mkNCount' :: m(NCount' 5))
    else if n < 64       then ffNM(mkNCount' :: m(NCount' 6))
    else if n < 128      then ffNM(mkNCount' :: m(NCount' 7))
    else if n < 256      then ffNM(mkNCount' :: m(NCount' 8))
    else if n < 512      then ffNM(mkNCount' :: m(NCount' 9))
    else if n < 1024     then ffNM(mkNCount' :: m(NCount' 10))
    else if n < 2048     then ffNM(mkNCount' :: m(NCount' 11))
    else if n < 4096     then ffNM(mkNCount' :: m(NCount' 12))
    else if n < 8192     then ffNM(mkNCount' :: m(NCount' 13))
    else if n < 16384    then ffNM(mkNCount' :: m(NCount' 14))
    else if n < 32768    then ffNM(mkNCount' :: m(NCount' 15))
    else if n < 65536    then ffNM(mkNCount' :: m(NCount' 16))
    else if n < 131072   then ffNM(mkNCount' :: m(NCount' 17))
    else if n < 262144   then ffNM(mkNCount' :: m(NCount' 18))
    else if n < 524288   then ffNM(mkNCount' :: m(NCount' 19))
    else if n < 1048576  then ffNM(mkNCount' :: m(NCount' 20))
    else if n < 2097152  then ffNM(mkNCount' :: m(NCount' 21))
    else if n < 4194304  then ffNM(mkNCount' :: m(NCount' 22))
    else if n < 8388608  then ffNM(mkNCount' :: m(NCount' 23))
    else if n < 16777216 then ffNM(mkNCount' :: m(NCount' 24))
    else if n < 33554432 then ffNM(mkNCount' :: m(NCount' 25))
    else if n < 67108864 then ffNM(mkNCount' :: m(NCount' 26))
    else error "Counter too big"

-- #############################################################################
-- #
-- #############################################################################

addNoActionState :: (Monad m) => TwoStateDescriptors -> LabelState a -> m (TwoStateDescriptors)
addNoActionState tsds ls =
 do let no_action (TSD _ f t _) = t == idle_state && f == idle_state
        no_action_list = filter no_action tsds
        rest tsd = not (no_action tsd)
        rest_list = filter rest tsds
        handle Nil                         = return tsds
        handle (Cons (TSD cond f t _) Nil) =
          do let num    = ls.state_num - 1
                 tsds'  =  (Cons (TSD cond f num Start) (Cons (TSD True num t Default) rest_list))
             tsds'' <- addWaitBypassTSDs idle_state tsds'
             let tsds''' = combineTSDs (sortBy compareTSDs tsds'')
             return tsds'''
        handle _                  = error "unhandled case"
    handle no_action_list


-- #############################################################################
-- #
-- #############################################################################

dummyAction :: Action
dummyAction = action {$write ""}

-- #############################################################################
-- #
-- #############################################################################

ruleName :: String -> Integer -> String -> String
-- ruleName text n suffix = (text +++ "_" +++ (integerToString n) +++ suffix)
ruleName text _ suffix = (text +++ suffix)

-- #############################################################################
-- #
-- #############################################################################



instance ToString TwoStateDescriptor where
    toString (TSD c from to Default) =
      "<TSD " +++ (boolToString c) +++ ", " +++ (integerToString from) +++ ", " +++ (integerToString to) +++ ">"
    toString (TSD c from to Start) =
      "<TSD " +++ (boolToString c) +++ ", " +++ (integerToString from) +++ ", " +++ (integerToString to) +++ " (S)>"
    toString (TSD c from to End) =
      "<TSD " +++ (boolToString c) +++ ", " +++ (integerToString from) +++ ", " +++ (integerToString to) +++ " (E)>"
